home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-digest.el.z / vm-digest.el
Encoding:
Text File  |  1998-05-21  |  27.1 KB  |  727 lines
  1. ;;; Message encapsulation
  2. ;;; Copyright (C) 1989, 1990, 1993, 1994, 1997 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-digest)
  19.  
  20. (defun vm-no-frills-encapsulate-message (m keep-list discard-regexp)
  21.   "Encapsulate a message M for forwarding, simply.
  22. No message encapsulation standard is used.  The message is
  23. inserted at point in the current buffer, surrounded by two dashed
  24. start/end separator lines.  Point is not moved.
  25.  
  26. M should be a message struct for a real message, not a virtual message.
  27. This is the message that will be encapsulated.
  28. KEEP-LIST should be a list of regexps matching headers to keep.
  29. DISCARD-REGEXP should be a regexp that matches headers to be discarded.
  30. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
  31. to be forwarded.  See the docs for vm-reorder-message-headers
  32. to find out how KEEP-LIST and DISCARD-REGEXP are used."
  33.   (let ((target-buffer (current-buffer))
  34.     source-buffer)
  35.     (save-restriction
  36.       ;; narrow to a zero length region to avoid interacting
  37.       ;; with anything that might have already been inserted
  38.       ;; into the buffer.
  39.       (narrow-to-region (point) (point))
  40.       (insert "------- start of forwarded message -------\n")
  41.       (setq source-buffer (vm-buffer-of m))
  42.       (save-excursion
  43.     (set-buffer source-buffer)
  44.     (save-restriction
  45.       (widen)
  46.       (save-excursion
  47.         (set-buffer target-buffer)
  48.         (let ((beg (point)))
  49.           (insert-buffer-substring source-buffer (vm-headers-of m)
  50.                        (vm-text-end-of m))
  51.           (goto-char beg)
  52.           (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)")
  53.           (vm-reorder-message-headers nil keep-list discard-regexp)))))
  54.       (goto-char (point-max))
  55.       (insert "------- end of forwarded message -------\n"))))
  56.  
  57. (defun vm-mime-encapsulate-messages (message-list keep-list discard-regexp
  58.                      always-use-digest)
  59.   "Encapsulate the messages in MESSAGE-LIST as per the MIME spec.
  60. The resulting digest is inserted at point in the current buffer.
  61. Point is not moved.
  62.  
  63. MESSAGE-LIST should be a list of message structs (real or virtual).
  64. These are the messages that will be encapsulated.
  65. KEEP-LIST should be a list of regexps matching headers to keep.
  66. DISCARD-REGEXP should be a regexp that matches headers to be discarded.
  67. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
  68. to be forwarded.  See the docs for vm-reorder-message-headers
  69. to find out how KEEP-LIST and DISCARD-REGEXP are used.
  70.  
  71. If ALWAYS-USE-DIGEST is non-nil, always encapsulate for a multipart/digest.
  72. Otherwise if there are fewer than two messages to be encapsulated
  73. leave off the multipart boundary strings.  The caller is assumed to
  74. be using message/rfc822 or message/news encoding instead.
  75.  
  76. If multipart/digest encapsulation is done, the function returns
  77. the multipart boundary parameter (string) that should be used in
  78. the Content-Type header.  Otherwise nil is returned."
  79.   (if message-list
  80.       (let ((target-buffer (current-buffer))
  81.         (boundary-positions nil)
  82.         (mlist message-list)
  83.         (mime-keep-list (append keep-list vm-mime-header-list))
  84.         (boundary nil)
  85.         source-buffer m start n beg)
  86.     (save-restriction
  87.       ;; narrow to a zero length region to avoid interacting
  88.       ;; with anything that might have already been inserted
  89.       ;; into the buffer.
  90.       (narrow-to-region (point) (point))
  91.       (setq start (point))
  92.       (while mlist
  93.         (setq boundary-positions (cons (point-marker) boundary-positions))
  94.         (setq m (vm-real-message-of (car mlist))
  95.           source-buffer (vm-buffer-of m))
  96.         (setq beg (point))
  97.         (vm-insert-region-from-buffer source-buffer (vm-headers-of m)
  98.                       (vm-text-end-of m))
  99.         (goto-char beg)
  100.         (vm-reorder-message-headers nil nil "\\(X-VM-\\|Status:\\)")
  101.         (vm-reorder-message-headers
  102.          nil (if (vm-mime-plain-message-p m)
  103.              keep-list
  104.            mime-keep-list)
  105.          discard-regexp)
  106.         (goto-char (point-max))
  107.         (setq mlist (cdr mlist)))
  108.       (if (and (< (length message-list) 2) (not always-use-digest))
  109.           nil
  110.         (goto-char start)
  111.         (setq boundary (vm-mime-make-multipart-boundary))
  112.         (while (re-search-forward (concat "^--"
  113.                           (regexp-quote boundary)
  114.                           "\\(--\\)?$")
  115.                       nil t)
  116.           (setq boundary (vm-mime-make-multipart-boundary))
  117.           (goto-char start))
  118.         (goto-char (point-max))
  119.         (insert "\n--" boundary "--\n")
  120.         (while boundary-positions
  121.           (goto-char (car boundary-positions))
  122.           (insert "\n--" boundary "\n\n")
  123.           (setq boundary-positions (cdr boundary-positions)))
  124.         (goto-char start)
  125.         (setq n (length message-list))
  126.         (insert
  127.          (format "This is a digest, %d messages, MIME encapsulation.\n"
  128.              n)))
  129.       (goto-char start))
  130.     boundary )))
  131.  
  132. (defun vm-mime-burst-message (m)
  133.   "Burst messages from the digest message M.
  134. M should be a message struct for a real message.
  135. MIME encoding is expected.  Somewhere within the MIME layout
  136. there must be at least one part of type message/news, message/rfc822 or
  137. multipart/digest.  If there are multiple parts matching those types,
  138. all of them will be burst."
  139.   (let ((ident-header nil)
  140.     (did-burst nil)
  141.     (list (vm-mime-find-digests-in-layout (vm-mm-layout m))))
  142.     (if vm-digest-identifier-header-format
  143.     (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m)))
  144.     (while list
  145.       (setq did-burst (or did-burst
  146.               (vm-mime-burst-layout (car list) ident-header)))
  147.       (setq list (cdr list)))
  148.     did-burst))
  149.  
  150. (defun vm-mime-burst-layout (layout ident-header)
  151.   (let ((work-buffer nil)
  152.     (folder-buffer (current-buffer))
  153.     start part-list
  154.     (folder-type vm-folder-type))
  155.     (unwind-protect
  156.     (vm-save-restriction
  157.      (save-excursion
  158.        (widen)
  159.        (setq work-buffer (generate-new-buffer "*vm-work*"))
  160.        (buffer-disable-undo work-buffer)
  161.        (set-buffer work-buffer)
  162.        (cond ((not (vectorp layout))
  163.           (error "Not a MIME message"))
  164.          ((vm-mime-types-match "message"
  165.                        (car (vm-mm-layout-type layout)))
  166.           (insert (vm-leading-message-separator folder-type))
  167.           (and ident-header (insert ident-header))
  168.           (setq start (point))
  169.           (vm-mime-insert-mime-body layout)
  170.           (vm-munge-message-separators folder-type start (point))
  171.           (insert (vm-trailing-message-separator folder-type)))
  172.          ((vm-mime-types-match "multipart/digest"
  173.                        (car (vm-mm-layout-type layout)))
  174.           (setq part-list (vm-mm-layout-parts layout))
  175.           (while part-list
  176.             ;; Maybe we should verify that each part is
  177.             ;; of type message/rfc822 or message/news in
  178.             ;; here.  But it seems more useful to just
  179.             ;; copy whatever the contents are and let the
  180.             ;; user see the goop, whatever type it really
  181.             ;; is.
  182.             (insert (vm-leading-message-separator folder-type))
  183.             (and ident-header (insert ident-header))
  184.             (setq start (point))
  185.             (vm-mime-insert-mime-body (car part-list))
  186.             (vm-munge-message-separators folder-type start (point))
  187.             (insert (vm-trailing-message-separator folder-type))
  188.             (setq part-list (cdr part-list))))
  189.          (t (error
  190.              "MIME type is not multipart/digest or message/rfc822 or message/news")))
  191.        ;; do header conversions.
  192.        (let ((vm-folder-type folder-type))
  193.          (goto-char (point-min))
  194.          (while (vm-find-leading-message-separator)
  195.            (vm-skip-past-leading-message-separator)
  196.            (vm-convert-folder-type-headers folder-type folder-type)
  197.            (vm-find-trailing-message-separator)
  198.            (vm-skip-past-trailing-message-separator)))
  199.        ;; now insert the messages into the folder buffer
  200.        (cond ((not (zerop (buffer-size)))
  201.           (set-buffer folder-buffer)
  202.           (let ((old-buffer-modified-p (buffer-modified-p))
  203.             (buffer-read-only nil)
  204.             (inhibit-quit t))
  205.             (goto-char (point-max))
  206.             (insert-buffer-substring work-buffer)
  207.             (set-buffer-modified-p old-buffer-modified-p)
  208.             ;; return non-nil so caller knows we found some messages
  209.             t ))
  210.          ;; return nil so the caller knows we didn't find anything
  211.          (t nil))))
  212.      (and work-buffer (kill-buffer work-buffer)))))
  213.  
  214. (defun vm-rfc934-char-stuff-region (start end)
  215.   "Quote RFC 934 message separators between START and END.
  216. START and END are buffer positions in the current buffer.
  217. Lines beginning with `-' in the region have `- ' prepended to them."
  218.   (setq end (vm-marker end))
  219.   (save-excursion
  220.     (goto-char start)
  221.     (while (and (< (point) end) (re-search-forward "^-" end t))
  222.       (replace-match "- -" t t)))
  223.   (set-marker end nil))
  224.  
  225. (defun vm-rfc934-char-unstuff-region (start end)
  226.   "Unquote lines in between START and END as per RFC 934.
  227. START and END are buffer positions in the current buffer.
  228. Lines beginning with `- ' in the region have that string stripped
  229. from them."
  230.   (setq end (vm-marker end))
  231.   (save-excursion
  232.     (goto-char start)
  233.     (while (and (< (point) end) (re-search-forward "^- "  end t))
  234.       (replace-match "" t t)
  235.       (forward-char)))
  236.   (set-marker end nil))
  237.  
  238. (defun vm-rfc934-encapsulate-messages (message-list keep-list discard-regexp)
  239.   "Encapsulate the messages in MESSAGE-LIST as per RFC 934.
  240. The resulting digest is inserted at point in the current buffer.
  241. Point is not moved.
  242.  
  243. MESSAGE-LIST should be a list of message structs (real or virtual).
  244. These are the messages that will be encapsulated.
  245. KEEP-LIST should be a list of regexps matching headers to keep.
  246. DISCARD-REGEXP should be a regexp that matches headers to be discarded.
  247. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
  248. to be forwarded.  See the docs for vm-reorder-message-headers
  249. to find out how KEEP-LIST and DISCARD-REGEXP are used."
  250.   (if message-list
  251.       (let ((target-buffer (current-buffer))
  252.         (mime-keep-list (append keep-list vm-mime-header-list))
  253.         (mlist message-list)
  254.         source-buffer m start n)
  255.     (save-restriction
  256.       ;; narrow to a zero length region to avoid interacting
  257.       ;; with anything that might have already been inserted
  258.       ;; into the buffer.
  259.       (narrow-to-region (point) (point))
  260.       (setq start (point))
  261.       (while mlist
  262.         (insert "---------------\n")
  263.         (setq m (vm-real-message-of (car mlist))
  264.           source-buffer (vm-buffer-of m))
  265.         (save-excursion
  266.           (set-buffer source-buffer)
  267.           (save-restriction
  268.         (widen)
  269.         (save-excursion
  270.           (set-buffer target-buffer)
  271.           (let ((beg (point)))
  272.             (insert-buffer-substring source-buffer (vm-headers-of m)
  273.                          (vm-text-end-of m))
  274.             (goto-char beg)
  275.             (vm-reorder-message-headers nil nil
  276.                         "\\(X-VM-\\|Status:\\)")
  277.             (vm-reorder-message-headers
  278.              nil (if (vm-mime-plain-message-p m)
  279.                  keep-list
  280.                mime-keep-list)
  281.              discard-regexp)
  282.             (vm-rfc934-char-stuff-region beg (point-max))))))
  283.         (goto-char (point-max))
  284.         (insert "---------------")
  285.         (setq mlist (cdr mlist)))
  286.       (delete-region (point) (progn (beginning-of-line) (point)))
  287.       (insert "------- end -------\n")
  288.       (goto-char start)
  289.       (delete-region (point) (progn (forward-line 1) (point)))
  290.       (setq n (length message-list))
  291.    (insert (format "------- start of %s%s(RFC 934 encapsulation) -------\n"
  292.               (if (cdr message-list)
  293.                   "digest "
  294.                 "forwarded message ")
  295.               (if (cdr message-list)
  296.                   (format "(%d messages) " n)
  297.                 "")))
  298.       (goto-char start)))))
  299.  
  300. (defun vm-rfc1153-char-stuff-region (start end)
  301.   "Quote RFC 1153 message separators between START and END.
  302. START and END are buffer positions in the current buffer.
  303. Lines consisting only of 30 hyphens have the first hyphen
  304. converted to a space."
  305.   (setq end (vm-marker end))
  306.   (save-excursion
  307.     (goto-char start)
  308.     (while (and (< (point) end)
  309.         (re-search-forward "^------------------------------$" end t))
  310.       (replace-match " -----------------------------" t t)))
  311.   (set-marker end nil))
  312.  
  313. (defun vm-rfc1153-char-unstuff-region (start end)
  314.   "Unquote lines in between START and END as per RFC 1153.
  315. START and END are buffer positions in the current buffer.
  316. Lines consisting only of a space following by 29 hyphens have the space
  317. converted to a hyphen."
  318.   (setq end (vm-marker end))
  319.   (save-excursion
  320.     (goto-char start)
  321.     (while (and (< (point) end)
  322.         (re-search-forward "^ -----------------------------$" end t))
  323.       (replace-match "------------------------------" t t)))
  324.   (set-marker end nil))
  325.  
  326. (defun vm-rfc1153-encapsulate-messages (message-list keep-list discard-regexp)
  327.   "Encapsulate the messages in MESSAGE-LIST as per RFC 1153.
  328. The resulting digest is inserted at point in the current buffer.
  329. Point is not moved.
  330.  
  331. MESSAGE-LIST should be a list of message structs (real or virtual).
  332. These are the messages that will be encapsulated.
  333. KEEP-LIST should be a list of regexps matching headers to keep.
  334. DISCARD-REGEXP should be a regexp that matches headers to be discarded.
  335. KEEP-LIST and DISCARD-REGEXP are used to order and trim the headers
  336. to be forwarded.  See the docs for vm-reorder-message-headers
  337. to find out how KEEP-LIST and DISCARD-REGEXP are used."
  338.   (if message-list
  339.       (let ((target-buffer (current-buffer))
  340.         (mime-keep-list (append keep-list vm-mime-header-list))
  341.         (mlist message-list)
  342.         source-buffer m start)
  343.     (save-restriction
  344.       ;; narrow to a zero length region to avoid interacting
  345.       ;; with anything that might have already been inserted
  346.       ;; into the buffer.
  347.       (narrow-to-region (point) (point))
  348.       (setq start (point))
  349.       (while mlist
  350.         (insert "---------------\n\n")
  351.         (setq m (vm-real-message-of (car mlist))
  352.           source-buffer (vm-buffer-of m))
  353.         (save-excursion
  354.           (set-buffer source-buffer)
  355.           (save-restriction
  356.         (widen)
  357.         (save-excursion
  358.           (set-buffer target-buffer)
  359.           (let ((beg (point)))
  360.             (insert-buffer-substring source-buffer (vm-headers-of m)
  361.                          (vm-text-end-of m))
  362.             (goto-char beg)
  363.             (vm-reorder-message-headers nil nil
  364.                         "\\(X-VM-\\|Status:\\)")
  365.             (vm-reorder-message-headers
  366.              nil (if (vm-mime-plain-message-p m)
  367.                  keep-list
  368.                mime-keep-list)
  369.              discard-regexp)
  370.             (vm-rfc1153-char-stuff-region beg (point-max))))))
  371.         (goto-char (point-max))
  372.         (insert "\n---------------")
  373.         (setq mlist (cdr mlist)))
  374.     (insert "---------------\n\nEnd of this Digest\n******************\n")
  375.       (goto-char start)
  376.       (delete-region (point) (progn (forward-line 1) (point)))
  377.       (insert (format "This is an RFC 1153 digest.\n(%d message%s)\n----------------------------------------------------------------------\n" (length message-list) (if (cdr message-list) "s" "")))
  378.       (goto-char start)))))
  379.  
  380. (defun vm-rfc1153-or-rfc934-burst-message (m rfc1153)
  381.   "Burst messages from the digest message M.
  382. M should be a message struct for a real message.
  383. If RFC1153 is non-nil, assume the digest is of the form specified by
  384. RFC 1153.  Otherwise assume RFC 934 digests."
  385.   (let ((work-buffer nil)
  386.     (match t)
  387.     (prev-sep nil)
  388.     (ident-header nil)
  389.     after-prev-sep prologue-separator-regexp separator-regexp
  390.     (folder-buffer (current-buffer))
  391.     (folder-type vm-folder-type))
  392.     (if vm-digest-identifier-header-format
  393.     (setq ident-header (vm-sprintf 'vm-digest-identifier-header-format m)))
  394.     (if rfc1153
  395.     (setq prologue-separator-regexp "^----------------------------------------------------------------------\n"
  396.           separator-regexp "^------------------------------\n")
  397.       (setq prologue-separator-regexp "\\(^-[^ ].*\n+\\)+"
  398.         separator-regexp "\\(^-[^ ].*\n+\\)+"))
  399.     (vm-save-restriction
  400.      (save-excursion
  401.        (widen)
  402.        (unwind-protect
  403.        (catch 'done
  404.          (setq work-buffer (generate-new-buffer "*vm-work*"))
  405.          (buffer-disable-undo work-buffer)
  406.          (set-buffer work-buffer)
  407.          (vm-insert-region-from-buffer (vm-buffer-of m)
  408.                        (vm-text-of m)
  409.                        (vm-text-end-of m))
  410.          (goto-char (point-min))
  411.          (if (not (re-search-forward prologue-separator-regexp nil t))
  412.          (throw 'done nil))
  413.          ;; think of this as a do-while loop.
  414.          (while match
  415.            (cond ((null prev-sep)
  416.               ;; from (point-min) to end of match
  417.               ;; is the digest prologue, devour it and
  418.               ;; carry on.
  419.               (delete-region (point-min) (match-end 0)))
  420.              (t
  421.               ;; munge previous messages message separators
  422.               (let ((md (match-data)))
  423.             (unwind-protect
  424.                 (vm-munge-message-separators
  425.                  folder-type
  426.                  after-prev-sep
  427.                  (match-beginning 0))
  428.               (store-match-data md)))))
  429.            ;; there should be at least one valid header at
  430.            ;; the beginning of an encapsulated message.  If
  431.            ;; there isn't a valid header, then assume that
  432.            ;; the digest was packed improperly and that this
  433.            ;; isn't a real boundary.
  434.            (if (not
  435.             (save-excursion
  436.               (save-match-data
  437.             (skip-chars-forward "\n")
  438.             (or (and (vm-match-header)
  439.                  (vm-digest-get-header-contents "From"))
  440.                 (not (re-search-forward separator-regexp
  441.                             nil t))))))
  442.            (setq prev-sep (point)
  443.              after-prev-sep (point))
  444.          ;; if this isn't the first message, delete the
  445.          ;; digest separator goop and insert a trailing message
  446.          ;; separator of the proper type.
  447.          (if prev-sep
  448.              (progn
  449.                ;; eat preceding newlines
  450.                (while (= (preceding-char) ?\n)
  451.              (delete-char -1))
  452.                ;; put one back
  453.                (insert ?\n)
  454.                ;; delete the digest separator
  455.                (delete-region (match-beginning 0) (point))
  456.                ;; insert a trailing message separator
  457.                (insert (vm-trailing-message-separator folder-type))))
  458.          (setq prev-sep (point))
  459.          ;; insert the leading separator
  460.          (insert (vm-leading-message-separator folder-type))
  461.          (setq after-prev-sep (point))
  462.          ;; eat trailing newlines
  463.          (while (= (following-char) ?\n)
  464.            (delete-char 1))
  465.          (insert ident-header))
  466.            ;; try to match message separator and repeat.
  467.            (setq match (re-search-forward separator-regexp nil t)))
  468.          ;; from the last separator to eof is the digest epilogue.
  469.          ;; discard it.
  470.          (delete-region (or prev-sep (point-min)) (point-max))
  471.          ;; Undo the quoting of the embedded message
  472.          ;; separators.  This must be done before header
  473.          ;; conversions, else the Content-Length offsets might be
  474.          ;; rendered invalid by buffer size changes.
  475.          (if rfc1153
  476.          (vm-rfc1153-char-unstuff-region (point-min) (point-max))
  477.            (vm-rfc934-char-unstuff-region (point-min) (point-max)))
  478.          ;; do header conversions.
  479.          (let ((vm-folder-type folder-type))
  480.            (goto-char (point-min))
  481.            (while (vm-find-leading-message-separator)
  482.          (vm-skip-past-leading-message-separator)
  483.          (vm-convert-folder-type-headers folder-type folder-type)
  484.          (vm-find-trailing-message-separator)
  485.          (vm-skip-past-trailing-message-separator)))
  486.          ;; now insert the messages into the folder buffer
  487.          (cond ((not (zerop (buffer-size)))
  488.             (set-buffer folder-buffer)
  489.             (let ((old-buffer-modified-p (buffer-modified-p))
  490.               (buffer-read-only nil)
  491.               (inhibit-quit t))
  492.               (goto-char (point-max))
  493.               (insert-buffer-substring work-buffer)
  494.               (set-buffer-modified-p old-buffer-modified-p)
  495.               ;; return non-nil so caller knows we found some messages
  496.               t ))
  497.            ;; return nil so the caller knows we didn't find anything
  498.            (t nil)))
  499.      (and work-buffer (kill-buffer work-buffer)))))))
  500.  
  501. (defun vm-rfc934-burst-message (m)
  502.   "Burst messages from the RFC 934 digest message M.
  503. M should be a message struct for a real message."
  504.   (vm-rfc1153-or-rfc934-burst-message m nil))
  505.  
  506. (defun vm-rfc1153-burst-message (m)
  507.   "Burst messages from the RFC 1153 digest message M.
  508. M should be a message struct for a real message."
  509.   (vm-rfc1153-or-rfc934-burst-message m t))
  510.  
  511. (defun vm-burst-digest (&optional digest-type)
  512.   "Burst the current message (a digest) into its individual messages.
  513. The digest's messages are assimilated into the folder as new mail
  514. would be.
  515.  
  516. Optional argument DIGEST-TYPE is a string that tells VM what kind
  517. of digest the current message is.  If it is not given the value
  518. defaults to the value of vm-digest-burst-type.  When called
  519. interactively DIGEST-TYPE will be read from the minibuffer.
  520.  
  521. If invoked on marked messages (via vm-next-command-uses-marks),
  522. all marked messages will be burst."
  523.   (interactive
  524.    (list
  525.     (let ((type nil)
  526.       (this-command this-command)
  527.       (last-command last-command))
  528.       (setq type (completing-read (format "Digest type: (default %s) "
  529.                       vm-digest-burst-type)
  530.                   (append vm-digest-type-alist
  531.                       (list '("guess")))
  532.                   'identity nil))
  533.       (if (string= type "")
  534.       vm-digest-burst-type
  535.     type ))))
  536.   (or digest-type (setq digest-type vm-digest-burst-type))
  537.   (vm-follow-summary-cursor)
  538.   (vm-select-folder-buffer)
  539.   (vm-check-for-killed-summary)
  540.   (vm-error-if-folder-empty)
  541.   (let ((start-buffer (current-buffer)) m totals-blurb
  542.     (mlist (vm-select-marked-or-prefixed-messages 1)))
  543.     (while mlist
  544.       (if (vm-virtual-message-p (car mlist))
  545.       (progn
  546.         (setq m (vm-real-message-of (car mlist)))
  547.         (set-buffer (vm-buffer-of m)))
  548.     (setq m (car mlist)))
  549.       (vm-error-if-folder-read-only)
  550.       (if (equal digest-type "guess")
  551.       (progn
  552.         (setq digest-type (vm-guess-digest-type m))
  553.         (if (null digest-type)
  554.         (error "Couldn't guess digest type."))))
  555.       (message "Bursting %s digest..." digest-type)
  556.       (cond
  557.        ((cond ((equal digest-type "mime")
  558.            (vm-mime-burst-message m))
  559.           ((equal digest-type "rfc934")
  560.            (vm-rfc934-burst-message m))
  561.           ((equal digest-type "rfc1153")
  562.            (vm-rfc1153-burst-message m))
  563.           (t (error "Unknown digest type: %s" digest-type)))
  564.     (message "Bursting %s digest... done" digest-type)
  565.     (vm-clear-modification-flag-undos)
  566.     (vm-set-buffer-modified-p t)
  567.     (vm-increment vm-modification-counter)
  568.     (and vm-delete-after-bursting
  569.          ;; if start folder was virtual, we're now in the wrong
  570.          ;; buffer.  switch back.
  571.          (save-excursion
  572.            (set-buffer start-buffer)
  573.            ;; don't move message pointer when deleting the message
  574.            (let ((vm-move-after-deleting nil))
  575.          (vm-delete-message 1))))
  576.     (vm-assimilate-new-messages t nil (vm-labels-of (car mlist)))
  577.     ;; do this now so if we error later in another iteration
  578.     ;; of the loop the summary and mode line will be correct.
  579.     (vm-update-summary-and-mode-line)))
  580.       (setq mlist (cdr mlist)))
  581.     ;; collect this data NOW, before the non-previewers read a
  582.     ;; message, alter the new message count and confuse
  583.     ;; themselves.
  584.     (setq totals-blurb (vm-emit-totals-blurb))
  585.     (vm-display nil nil '(vm-burst-digest
  586.               vm-burst-mime-digest
  587.               vm-burst-rfc934-digest
  588.               vm-burst-rfc1153-digest)
  589.         (list this-command))
  590.     (if (vm-thoughtfully-select-message)
  591.     (vm-preview-current-message)
  592.       (vm-update-summary-and-mode-line))
  593.     (message totals-blurb)))
  594.  
  595. (defun vm-burst-rfc934-digest ()
  596.   "Burst an RFC 934 style digest"
  597.   (interactive)
  598.   (vm-burst-digest "rfc934"))
  599.  
  600. (defun vm-burst-rfc1153-digest ()
  601.   "Burst an RFC 1153 style digest"
  602.   (interactive)
  603.   (vm-burst-digest "rfc1153"))
  604.  
  605. (defun vm-burst-mime-digest ()
  606.   "Burst a MIME digest"
  607.   (interactive)
  608.   (vm-burst-digest "mime"))
  609.  
  610. (defun vm-burst-digest-to-temp-folder (&optional digest-type)
  611.   "Burst the current message (a digest) into a temporary folder.
  612. The digest's messages are copied to a buffer and vm-mode is
  613. invoked on the buffer.  There is no file associated with this
  614. buffer.  You can use `vm-write-file' to save the buffer, or
  615. `vm-save-message' to save individual messages to a real folder.
  616.  
  617. Optional argument DIGEST-TYPE is a string that tells VM what kind
  618. of digest the current message is.  If it is not given the value
  619. defaults to the value of vm-digest-burst-type.  When called
  620. interactively DIGEST-TYPE will be read from the minibuffer.
  621.  
  622. If invoked on marked messages (via vm-next-command-uses-marks),
  623. all marked messages will be burst."
  624.   (interactive
  625.    (list
  626.     (let ((type nil)
  627.       (this-command this-command)
  628.       (last-command last-command))
  629.       (setq type (completing-read (format "Digest type: (default %s) "
  630.                       vm-digest-burst-type)
  631.                   (append vm-digest-type-alist
  632.                       (list '("guess")))
  633.                   'identity nil))
  634.       (if (string= type "")
  635.       vm-digest-burst-type
  636.     type ))))
  637.   (or digest-type (setq digest-type vm-digest-burst-type))
  638.   (vm-follow-summary-cursor)
  639.   (vm-select-folder-buffer)
  640.   (vm-check-for-killed-summary)
  641.   (vm-error-if-folder-empty)
  642.   (let ((start-buffer (current-buffer)) m totals-blurb
  643.     (mlist (vm-select-marked-or-prefixed-messages 1))
  644.     (work-buffer nil))
  645.     (unwind-protect
  646.     (save-excursion
  647.       (setq work-buffer (generate-new-buffer
  648.                  (format "digest from %s/%s%s"
  649.                      (current-buffer)
  650.                      (vm-number-of (car vm-message-pointer))
  651.                      (if (cdr mlist) " ..." ""))))
  652.       (set-buffer work-buffer)
  653.       (setq vm-folder-type vm-default-folder-type)
  654.       (while mlist
  655.         (if (vm-virtual-message-p (car mlist))
  656.         (setq m (vm-real-message-of (car mlist)))
  657.           (setq m (car mlist)))
  658.         (if (equal digest-type "guess")
  659.         (progn
  660.           (setq digest-type (vm-guess-digest-type m))
  661.           (if (null digest-type)
  662.               (error "Couldn't guess digest type."))))
  663.         (message "Bursting %s digest to folder..." digest-type)
  664.         (cond ((equal digest-type "mime")
  665.            (vm-mime-burst-message m))
  666.           ((equal digest-type "rfc934")
  667.            (vm-rfc934-burst-message m))
  668.           ((equal digest-type "rfc1153")
  669.            (vm-rfc1153-burst-message m))
  670.           (t (error "Unknown digest type: %s" digest-type)))
  671.         (message "Bursting %s digest... done" digest-type)
  672.         (setq mlist (cdr mlist)))
  673.       (set-buffer-modified-p nil)
  674.       (vm-save-buffer-excursion
  675.        (vm-goto-new-folder-frame-maybe 'folder)
  676.        (vm-mode)
  677.        (if (vm-should-generate-summary)
  678.            (progn
  679.          (vm-goto-new-folder-frame-maybe 'summary)
  680.          (vm-summarize))))
  681.       ;; temp buffer, don't offer to save it.
  682.       (setq buffer-offer-save nil)
  683.       (vm-display (or vm-presentation-buffer (current-buffer)) t
  684.               (list this-command) '(vm-mode startup))
  685.       (setq work-buffer nil))
  686.       (and work-buffer (kill-buffer work-buffer)))))
  687.  
  688. (defun vm-guess-digest-type (m)
  689.   "Guess the digest type of the message M.
  690. M should be the message struct of a real message.
  691. Returns either \"rfc934\", \"rfc1153\" or \"mime\"."
  692.   (catch 'return-value
  693.     (save-excursion
  694.       (set-buffer (vm-buffer-of m))
  695.       (let ((layout (vm-mm-layout m)))
  696.     (if (and (vectorp layout)
  697.          (or (vm-mime-layout-contains-type
  698.               layout
  699.               "multipart/digest")
  700.              (vm-mime-layout-contains-type
  701.               layout
  702.               "message/rfc822")
  703.              (vm-mime-layout-contains-type
  704.               layout
  705.               "message/news")))
  706.         (throw 'return-value "mime"))))
  707.     (save-excursion
  708.       (save-restriction
  709.     (widen)
  710.     (goto-char (vm-text-of m))
  711.     (cond ((search-forward "\n----------------------------------------------------------------------\n" (vm-text-end-of m) t)
  712.            "rfc1153")
  713.           (t "rfc934"))))))
  714.  
  715. (defun vm-digest-get-header-contents (header-name-regexp)
  716.   (let ((contents nil)
  717.     regexp)
  718.     (setq regexp (concat "^\\(" header-name-regexp "\\)\\|\\(^$\\)"))
  719.     (save-excursion
  720.       (let ((case-fold-search t))
  721.     (if (and (re-search-forward regexp nil t)
  722.          (match-beginning 1)
  723.          (progn (goto-char (match-beginning 0))
  724.             (vm-match-header)))
  725.         (vm-matched-header-contents)
  726.       nil )))))
  727.